Libris Britannia 4/science library(b).zip/science library(b)/PROGRAMM/DB_CLIPP/0769B.ZIP/DBF2TPV3.PAS

Pascal/Delphi Source File | 1986-06-29 | 29KB | 876 lines

  (*
  DBF.PAS version 1.3
  Copyright (C) 1986 By James Troutman
  CompuServe PPN 74746,1567
  Permission is granted to use these routines for non-commercial purposes.
  For commercial use, please request permission via EasyPlex.

  Version 1.3 -- Routines to access ANY dBASE .DBF file (2, 3, or 3+).  In
  addition to support for dBASE 2 files, a CreateDbf procedure has been
  added. Sample program simulates DISPLAY STRUCTURE and LIST and copies any
  DBF file to any other (e.g., converts a dBASE 2 file to dBASE 3). Requires
  Turbo 3.01A and PC DOS.


   Revision history
   1.1  - 5/6/86 - update header when modifying the .DBF file; write the
   End Of File marker; simplify use.

   1.2  - 5/27/86 - removed (some of) the absurdities from the code;
   allocate the current record buffer on the heap rather than in the data
   segment; symbol names changed to avoid conflicts; some error checking
   added.

   1.3  - 6/5/86 - added support for dBASE II files; new procedure CreateDbf.

                    !!!!ATTENTION!!!!
  If you have downloaded an earlier version of this file, please note that
  several of the TYPEs and VARs have been changed.  You may have to make
  some adjustments to any existing programs you have that use these routines.

  The routines in this file present some tools for accessing dBASE II, III, and
  III Plus files from within a Turbo Pascal program.  There is MUCH
  room for improvement: the error checking is simplistic, there is no support
  for memo files, no buffering of data, no support for index files,
  etc. The main routines are:

         PROCEDURE OpenDbf(VAR D : dbfRecord;) : Integer;
         PROCEDURE CloseDbf(VAR D : dbfRecord) : Integer;
         PROCEDURE GetDbfRecord(VAR D : dbfRecord; RecNum : Real);
         PROCEDURE PutDbfRecord(VAR D : dbfRecord; RecNum : Real);
         PROCEDURE AppendDbf(VAR D : dbfRecord);
         PROCEDURE CreateDbf(VAR D : dbfRecord; fn : _Str64; n : Integer;
                             flds : _dFields);

  After calling one of the procedures, check the status of the Boolean variable
  dbfOK to determine the success or failure of the operation.  If it failed,
  dbfError will contain a value corresponding to the IOResult value or
  to a specially assigned value for several special conditions.  Notice in
  particular that an unsuccessful call to CloseDbf will leave the file status
  unchanged and the memory still allocated.  It is your program's
  responsibility to take appropriate action.

  A skeletal program might go something like:
    {$I Dbf.PAS}
    VAR
      D : dbfRecord; { declare your dBASE file variable }
    BEGIN
    D.FileName := 'MyFile.DBF'; { get filename of .dbf file into FileName field
                                  of D variable ...  }
    OpenDbf(D);        { to open the file }
    IF NOT dbfOK THEN { check dbfError and process error };
    {... the rest of your program including calls to
     GetDbfRecord, PutDbfRecord, AppendDbf as needed,
     always remembering to interrogate the two global status
     variables after each procedure call   }
    CloseDbf(D);      { to close the file  }
    IF NOT dbfOK THEN { check dbfError and process error };
    END.

  Upon exit from the GetDbfRecord Procedure, the CurRecord of the
  dbfRecord variable points to the current record contents.  Each field
  can be accessed using its offset into the CurRecord^ with the variable
  Off in the Fields^ array.
  Upon entry to the PutDbfRecord Procedure, the CurRecord^ should contain
  the data that you want to write.
  AppendDbf automatically adds a record to the end of the file (the
  CurRecord^ should contain the data that you want to write).

  Notice that the OpenDbf routine does allocate a buffer on the heap for
  the current record.  You can, of course, override this by pointing
  CurRecord to any data structure that you wish; HOWEVER, since CloseDbf
  deallocates the buffer, you must repoint CurRecord to its original buffer
  before calling CloseDbf.

  See the demo program for some examples.
  If you have any problems with these routines, please
  let me know.  Suggestions for improvements gratefully accepted.
  *)

(*
dBASE III Database File Structure
The structure of a dBASE III database file is composed of a
header and data records.  The layout is given below.
dBASE III DATABASE FILE HEADER:
+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0      |  1 byte           | dBASE III version number        |
|         |                   |  (03H without a .DBT file)      |
|         |                   |  (83H with a .DBT file)         |
+---------+-------------------+---------------------------------+
|  1-3    |  3 bytes          | date of last update             |
|         |                   |  (YY MM DD) in binary format    |
+---------+-------------------+---------------------------------+
|  4-7    |  32 bit number    | number of records in data file  |
+---------+-------------------+---------------------------------+
|  8-9    |  16 bit number    | length of header structure      |
+---------+-------------------+---------------------------------+
|  10-11  |  16 bit number    | length of the record            |
+---------+-------------------+---------------------------------+
|  12-31  |  20 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
|  32-n   |  32 bytes each    | field descriptor array          |
|         |                   |  (see below)                    | --+
+---------+-------------------+---------------------------------+   |
|  n+1    |  1 byte           | 0DH as the field terminator     |   |
+---------+-------------------+---------------------------------+   |
|
|
A FIELD DESCRIPTOR:      <------------------------------------------+
+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0-10   |  11 bytes         | field name in ASCII zero-filled |
+---------+-------------------+---------------------------------+
|  11     |  1 byte           | field type in ASCII             |
|         |                   |  (C N L D or M)                 |
+---------+-------------------+---------------------------------+
|  12-15  |  32 bit number    | field data address              |
|         |                   |  (address is set in memory)     |
+---------+-------------------+---------------------------------+
|  16     |  1 byte           | field length in binary          |
+---------+-------------------+---------------------------------+
|  17     |  1 byte           | field decimal count in binary   |
+---------+-------------------+--------------------------------
|  18-31  |  14 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
The data records are layed out as follows:
1. Data records are preceeded by one byte that is a
space (20H) if the record is not deleted and an
asterisk (2AH) if it is deleted.
2. Data fields are packed into records with no field
separators or record terminators.
3. Data types are stored in ASCII format as follows:
DATA TYPE      DATA RECORD STORAGE
---------      --------------------------------------------
Character      (ASCII characters)
Numeric        - . 0 1 2 3 4 5 6 7 8 9
Logical        ? Y y N n T t F f  (? when not initialized)
Memo           (10 digits representing a .DBT block number)
Date           (8 digits in YYYYMMDD format, such as
19840704 for July 4, 1984)

This information came directly from the Ashton-Tate Forum.
It can also be found in the Advanced Programmer's Guide available
from Ashton-Tate.

One slight difference occurs between files created by dBASE III and those
created by dBASE III Plus.  In the earlier files, there is an ASCII NUL
character between the $0D end of header indicator and the start of the data.
This NUL is no longer present in Plus, making a Plus header one byte smaller
than an identically structured III file.
*)

CONST
  DB2File = 2;
  DB3File = 3;
  DB3WithMemo = $83;
  ValidTypes : SET OF Char = ['C', 'N', 'L', 'M', 'D'];
  MAX_HEADER = 4129;          { = maximum length of dBASE III header }
  MAX_BYTES_IN_RECORD = 4000; { dBASE III record limit }
  MAX_FIELDS_IN_RECORD = 128; { dBASE III field limit  }
  BYTES_IN_MEMO_RECORD = 512; { dBASE III memo field record size }

  { Special Error codes for .DBF files }
  NOT_DB_FILE = $80;  { first byte was not a $3 or $83 or a $2 (dBASE II)}
  INVALID_FIELD = $81;{ invalid field type was found }
  REC_TOO_HIGH = $82; { tried to read a record beyond the correct range }
  PARTIAL_READ = $83; { only a partial record was read }

  (*
  Although there are some declarations for memo files, the routines to access
  them have not yet been implemented.
  *)

TYPE
  _HeaderType = ARRAY[0..MAX_HEADER] OF Byte;
  _HeaderPrologType = ARRAY[0..31] OF Byte;
  _FieldDescType = ARRAY[0..31] OF Byte;
  _dRec = ^_DataRecord;
  _DataRecord = ARRAY[0..MAX_BYTES_IN_RECORD] OF Byte;
  _Str255 = STRING[255];
  _Str80 = STRING[80];
  _Str64 = STRING[64];
  _Str10 = STRING[10];
  _Str8 = STRING[8];
  _Str2 = STRING[2];
  _dbfFile = FILE;
  _FieldRecord = RECORD
                  Name : _Str10;
                  Typ : Char;
                  Len : Byte;
                  Dec : Byte;
                  Off : Integer;
                END;
  _FieldArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF _FieldRecord;
  _dFields = ^_FieldArray;
  _MemoRecord = ARRAY[1..BYTES_IN_MEMO_RECORD] OF Byte;
  _MemoFile = FILE OF _MemoRecord;
  _StatusType = (NotOpen, NotUpdated, Updated);
  dbfRecord = RECORD
                FileName : _Str64;
                dFile : _dbfFile;
                HeadProlog : _HeaderPrologType;
                dStatus : _StatusType;
                WithMemo : Boolean;
                DateOfUpdate : _Str8;
                NumRecs : Real;
                HeadLen : Integer;
                RecLen : Integer;
                NumFields : Integer;
                Fields : _dFields;
                CurRecord : _dRec;
              END;

  VAR
    dbfError : Integer; { global error indicators }
    dbfOK  : Boolean;

  FUNCTION MakeReal(VAR b) : Real;
    { takes a long 32-bit integer and converts it to a real }

  VAR
    r : ARRAY[1..4] OF Byte ABSOLUTE b;

  BEGIN
  MakeReal := (r[1]*1.0)+(r[2]*256.0)+(r[3]*65536.0)+(r[4]*16777216.0);
  END;

  FUNCTION MakeUnsignedReal(VAR b) : Real;
    { takes an unsigned 16-bit integer and converts it to a real }

  VAR
    r : ARRAY[1..2] OF Byte ABSOLUTE b;

  BEGIN
  MakeUnsignedReal := (r[1]*1.0)+(r[2]*256.0);
  END;

  FUNCTION MakeInt(VAR b) : Integer;
  VAR
    i : Integer ABSOLUTE b;

  BEGIN
  MakeInt := i;
  END;

  FUNCTION MakeStr(b : Byte) : _Str2;
  VAR
    i : Integer;
    s : _Str2;
  BEGIN
  i := b;
  Str(i:2, s);
  IF s[1] = ' ' THEN s[1] := '0';
  MakeStr := s;
  END;

  PROCEDURE GetDbfRecord(VAR D : dbfRecord; RecNum : Real);

  VAR
    Result : Integer;

  BEGIN
  IF RecNum > D.NumRecs THEN
    BEGIN
    dbfError := REC_TOO_HIGH;
    dbfOK := FALSE;
    Exit;
    END;
  {$I-} LongSeek(D.dFile, D.HeadLen+(RecNum-1)*D.RecLen); {$I+}
  dbfError := IOResult;
  IF dbfError = 0 THEN
    BEGIN
    {$I-} BlockRead(D.dFile, D.CurRecord^, D.RecLen, Result); {$I+}
    dbfError := IOResult;
    IF (dbfError = 0) AND (Result < D.RecLen) THEN
      dbfError := PARTIAL_READ;
    END;
  dbfOK := (dbfError = 0);
  END;                        {GetDbfRecord}

  PROCEDURE PutDbfRecord(VAR D : dbfRecord; RecNum : Real);

  VAR
    Result : Integer;

  BEGIN
  IF RecNum > D.NumRecs THEN
    BEGIN
    RecNum := D.NumRecs+1;
    D.NumRecs := RecNum;
    END;
  {$I-} LongSeek(D.dFile, D.HeadLen+(RecNum-1)*D.RecLen); {$I+}
  dbfError := IOResult;
  IF dbfError = 0 THEN
    BEGIN
    {$I-} BlockWrite(D.dFile, D.CurRecord^, D.RecLen, Result); {$I+}
    dbfError := IOResult;
    END;
  IF dbfError = 0 THEN D.dStatus := Updated;
  dbfOK := (dbfError = 0);
  END;                        {PutDbfRecord}

  PROCEDURE AppendDbf(VAR D : dbfRecord);

  BEGIN
  PutDbfRecord(D, D.NumRecs+1);
  END;

  PROCEDURE CloseDbf(VAR D : dbfRecord);

    PROCEDURE UpdateHeader(VAR D : dbfRecord);

    TYPE
      RegType = RECORD CASE Byte OF
        1 : (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer);
        2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
                END;

    VAR
      Reg : RegType;
      r : Real;

    BEGIN                     { UpdateHeader }
    r := D.NumRecs;
    Reg.AX := $2A00;          { Get DOS Date }
    Intr($21, Reg);
    IF D.HeadProlog[0] = DB2File THEN
      BEGIN
      D.HeadProlog[5] := Reg.CX-1900; {Year}
      D.HeadProlog[3] := Reg.DH; {Month}
      D.HeadProlog[4] := Reg.DL; {Day}
      D.HeadProlog[2] := Trunc(r/256.0);
      r := r-(D.HeadProlog[5]*256.0);
      D.HeadProlog[1] := Trunc(r);
      END
    ELSE
      BEGIN
      D.HeadProlog[1] := Reg.CX-1900; {Year}
      D.HeadProlog[2] := Reg.DH; {Month}
      D.HeadProlog[3] := Reg.DL; {Day}
      D.HeadProlog[7] := Trunc(r/16777216.0);
      r := r-(D.HeadProlog[7]*16777216.0);
      D.HeadProlog[6] := Trunc(r/65536.0);
      r := r-(D.HeadProlog[6]*65536.0);
      D.HeadProlog[5] := Trunc(r/256);
      r := r-(D.HeadProlog[5]*256);
      D.HeadProlog[4] := Trunc(r);
      END;
    {$I-}LongSeek(D.dFile, 0);{$I+}
    dbfError := IOResult;
    IF dbfError = 0 THEN
      BEGIN
      {$I-} BlockWrite(D.dFile, D.HeadProlog, 8); {$I+}
      dbfError := IOResult;
      END;
    dbfOK := (dbfError = 0);
    END;                      { UpdateHeader }

  CONST
    EofMark : Byte = $1A;

  BEGIN                       { CloseDbf }
  dbfError := 0;
  IF D.dStatus = Updated THEN
    BEGIN
    UpdateHeader(D);
    IF dbfError = 0 THEN
      BEGIN
      {$I-} LongSeek(D.dFile, D.HeadLen+D.NumRecs*D.RecLen); {$I+}
      dbfError := IOResult;
      END;
    IF dbfError = 0 THEN
      BEGIN
      {$I-} BlockWrite(D.dFile, EofMark, 1); {$I+} {Put EOF marker }
      dbfError := IOResult;
      END;
    END;   { IF Updated }
  IF dbfError = 0 THEN
    BEGIN
    {$I-} Close(D.dFile);     {$I+}
    dbfError := IOResult;
    END;
  IF dbfError = 0 THEN
    BEGIN
      D.dStatus := NotOpen;
      FreeMem(D.CurRecord, D.RecLen);
      FreeMem(D.Fields, D.NumFields*SizeOf(_FieldRecord));
    END;
  dbfOK := (dbfError = 0);
  END;                        { CloseDbf }

  PROCEDURE OpenDbf(VAR D : dbfRecord);

    PROCEDURE ProcessHeader(VAR Header : _HeaderType; NumBytes : Integer);

      PROCEDURE GetOneFieldDesc(VAR F; VAR Field : _FieldRecord;
                                VAR Offset : Integer);

      VAR
        i : Integer;
        FD : _FieldDescType ABSOLUTE F;

      BEGIN                   { GetOneFieldDesc }
      i := 0;
      Field.Name := '';
      REPEAT
        Field.Name[Succ(i)] := Chr(FD[i]);
        i := Succ(i);
      UNTIL FD[i] = 0;
      Field.Name[0] := Chr(i);
      Field.Typ := Char(FD[11]);
      IF D.HeadProlog[0] = DB2File THEN
        BEGIN
        Field.Len := FD[12];
        Field.Dec := FD[15];
        END
      ELSE
        BEGIN
        Field.Len := FD[16];
        Field.Dec := FD[17];
        END;
      Field.Off := Offset;
      Offset := Offset+Field.Len;
      IF NOT(Field.Typ IN ValidTypes) THEN
        dbfError := INVALID_FIELD;
      END;                    { GetOneFieldDesc }

      PROCEDURE ProcessDB2Header;

      VAR
        o, i, tFieldsLen : Integer;
        tempFields : _FieldArray;

      BEGIN   { ProcessDB2Header }
      D.DateOfUpdate := MakeStr(Header[3])+'/'+MakeStr(Header[4])+'/'+MakeStr(Header[5]);
      D.NumRecs := MakeUnsignedReal(Header[1]);
      D.HeadLen := 521;
      IF NumBytes < D.HeadLen THEN
        BEGIN
        dbfError := NOT_DB_FILE;
        Close(D.dFile);
        Exit;
        END;
      D.RecLen := MakeInt(Header[6]); { Includes the Deleted Record Flag }
      GetMem(D.CurRecord, D.RecLen); { Allocate some memory for a buffer  }
      D.dStatus := NotUpdated;
      D.NumFields := 0;
      Move(Header, D.HeadProlog, SizeOf(D.HeadProlog));
      o := 1;                   {Offset within dbf record of current field }
      i := 8;                   {Index for Header }
      WHILE Header[i] <> $0D DO
        BEGIN
        D.NumFields := Succ(D.NumFields);
        GetOneFieldDesc(Header[i], tempFields[D.NumFields], o);
        IF dbfError <> 0 THEN
          BEGIN
          Close(D.dFile);
          Exit;
          END;
        i := i+16;
        END;                    { While Header[i] <> $0D }
      tFieldsLen := D.NumFields*SizeOf(_FieldRecord);
      GetMem(D.Fields, tFieldsLen);
      Move(tempFields, D.Fields^, tFieldsLen);
      D.WithMemo := FALSE;
      END;                      {ProcessDB2Header}

    VAR
      o, i : Integer;
      tempFields : _FieldArray;

    BEGIN                     {ProcessHeader}
    CASE Header[0] OF
      DB2File : BEGIN
                  ProcessDB2Header;
                  Exit;
                END;
      DB3File : D.WithMemo := False;
      DB3WithMemo : D.WithMemo := True;
      ELSE
        BEGIN
        dbfError := NOT_DB_FILE;
        Close(D.dFile);
        Exit;
        END;
      END;                      {CASE}
    D.DateOfUpdate := MakeStr(Header[2])+'/'+MakeStr(Header[3])+'/'+MakeStr(Header[1]);
    D.NumRecs := MakeReal(Header[4]);
    D.HeadLen := MakeInt(Header[8]);
    IF NumBytes < D.HeadLen THEN
      BEGIN
      dbfError := NOT_DB_FILE;
      Close(D.dFile);
      Exit;
      END;
    D.RecLen := MakeInt(Header[10]); { Includes the Deleted Record Flag }
    GetMem(D.CurRecord, D.RecLen); { Allocate some memory for a buffer  }
    D.dStatus := NotUpdated;
    D.NumFields := 0;
    Move(Header, D.HeadProlog, SizeOf(D.HeadProlog));
    o := 1;                   {Offset within dbf record of current field }
    i := 32;                  {Index for Header }
    WHILE Header[i] <> $0D DO
      BEGIN
      D.NumFields := Succ(D.NumFields);
      GetOneFieldDesc(Header[i], tempFields[D.NumFields], o);
      IF dbfError <> 0 THEN
        BEGIN
        Close(D.dFile);
        Exit;
        END;
      i := i+32;
      END;                    { While Header[i] <> $0D }
    i := D.NumFields*SizeOf(_FieldRecord);
    GetMem(D.Fields,i) ;
    Move(tempFields, D.Fields^, i);
    END;                      {ProcessHeader}

    PROCEDURE GetHeader;

    VAR
      Result : Integer;
      H : _HeaderType;

    BEGIN                     { GetHeader }
    {$I-} BlockRead(D.dFile, H, MAX_HEADER, Result); {$I+}
    dbfError := IOResult;
    IF dbfError = 0 THEN ProcessHeader(H, Result);
    END;                      { GetHeader }

  BEGIN                       { OpenDbf }
  Assign(D.dFile, D.FileName);
  {$I-} Reset(D.dFile, 1); {$I+} {the '1' parameter sets the record size}
  dbfError := IOResult;
  IF dbfError = 0 THEN GetHeader;
  dbfOK := (dbfError = 0);
  END;                        { OpenDbf }

  PROCEDURE CreateDbf(VAR D : dbfRecord; fn : _Str64; n : Integer;
                      flds : _dFields);
    {
    Call this procedure with the full pathname of the file that you want
    to create (fn), the number of fields in a record (n), and a pointer
    to an array of _FieldRecord (flds).  The procedure will initialize all
    the data structures in the dbfRecord (D).
    }

  VAR
    tHeader : _HeaderType;

    PROCEDURE MakeFieldDescs;

      PROCEDURE MakeOneFieldDesc(VAR F; VAR Field : _FieldRecord);

      VAR
        FD : _FieldDescType ABSOLUTE F;

      BEGIN                   { MakeOneFieldDesc }
      Move(Field.Name[1],FD,Ord(Field.Name[0]));
      FD[11] := Ord(Field.Typ);
      FD[16] := Field.Len;
      IF Field.Typ <> 'N' THEN Field.Dec := 0;
      FD[17] := Field.Dec;
      Field.Off := D.RecLen;
      D.RecLen := D.RecLen+Field.Len;
      IF NOT(Field.Typ IN ValidTypes) THEN dbfError := INVALID_FIELD;
      IF Field.Typ = 'M' THEN D.WithMemo := TRUE;
      END;                    { MakeOneFieldDesc }

    VAR
      i : Integer;

    BEGIN                     {MakeFieldDescs}
    D.RecLen := 1;
    FOR i := 1 TO D.NumFields DO
      BEGIN
      MakeOneFieldDesc(tHeader[i*32],flds^[i]);
      IF dbfError <> 0 THEN Exit;
      END;
    END;                      {MakeFieldDescs}

    PROCEDURE MakeHeader;

    VAR
      Result : Integer;

    BEGIN                     { MakeHeader }
    FillChar(tHeader,SizeOf(tHeader),#0);
    D.WithMemo := FALSE;
    D.HeadLen := Succ(D.NumFields) * 32;
    tHeader[D.HeadLen] := $0D;
    D.HeadLen := Succ(D.HeadLen);
    tHeader[8] := Lo(D.HeadLen);
    tHeader[9] := Hi(D.HeadLen);
    MakeFieldDescs;
    IF D.WithMemo THEN
      tHeader[0] := DB3WithMemo
    ELSE
      tHeader[0] := DB3File;
    tHeader[10] := Lo(D.RecLen);
    tHeader[11] := Hi(D.RecLen);
    END;                      { MakeHeader }

  VAR
    i : Integer;

  BEGIN            { CreateDbf }
  D.NumFields := n;
  MakeHeader;
  D.FileName := fn;
  Assign(D.dFile, D.FileName);
  {$I-} Rewrite(D.dFile, 1); {$I+} {Will overwrite if file exists!}
  dbfError := IOResult;
  IF dbfError = 0 THEN
    BEGIN
    {$I-} BlockWrite(D.dFile,tHeader,Succ(D.HeadLen));{$I+}
    dbfError := IOResult;
    END;
  IF dbfError = 0 THEN
    BEGIN
    D.dStatus := Updated;
    D.NumRecs := 0.0;
    Move(tHeader,D.HeadProlog,SizeOf(D.HeadProlog));
    D.DateOfUpdate := '  /  /  ';
    GetMem(D.CurRecord, D.RecLen); { Allocate some memory for a buffer  }
    FillChar(D.CurRecord^,D.RecLen,' ');
    i := D.NumFields*SizeOf(_FieldRecord);
    GetMem(D.Fields,i);
    Move(flds, D.Fields^,i);
    END;
  dbfOK := (dbfError = 0);
  END;                        { CreateDbf }

(* To enable the Demo program, delete the next line. *)
(*

  PROCEDURE ErrorHalt(errorCode : Integer);
    { a VERY crude error handler }
  VAR
    errorMsg : _Str80;

  BEGIN
  CASE errorCode OF
     00 : Exit;                { no error occurred }
    $01 : errorMsg := 'Not found';
    $02 : errorMsg := 'Not open for input';
    $03 : errorMsg := 'Not open for output';
    $04 : errorMsg := 'Just not open';
    $91 : errorMsg := 'Seek beyond EOF';
    $99 : errorMsg := 'Unexpected EOF';
    $F0 : errorMsg := 'Disk write error';
    $F1 : errorMsg := 'Directory full';
    $F3 : errorMsg := 'Too many files';
    $FF : errorMsg := 'Where did that file go?';
    NOT_DB_FILE : errorMsg := 'Not a dBASE data file';
    INVALID_FIELD : errorMsg := 'Invalid field type encountered';
    REC_TOO_HIGH  : errorMsg := 'Requested record beyond range';
    PARTIAL_READ  : errorMsg := 'Tried to read beyon EOF';
    ELSE
     errorMsg := 'Undefined error';
    END;
  WriteLn;
  WriteLn(errorCode:3, ': ',errorMsg);
  Halt(1);
  END;

TYPE
  PseudoStr = ARRAY[1..255] OF Char;

VAR
  Demo : dbfRecord;
  j, i : Integer;
  blanks : _Str255;
  SizeOfFile, r : Real;
  fn : _Str64;

  PROCEDURE Wait;
  VAR
    c : Char;

  BEGIN
  Write('Press any key to continue . . .');
  Read(Kbd, c);
  END;


  PROCEDURE List(VAR D : dbfRecord);

    PROCEDURE ShowField(VAR a; VAR F : _FieldRecord);

    VAR
      Data : PseudoStr ABSOLUTE a;

    BEGIN
    WITH F DO
      BEGIN
      CASE Typ OF
        'C', 'N', 'L' : Write(Copy(Data, 1, Len));
        'M' : Write('Memo      ');
        'D' : Write(Copy(Data, 5, 2), '/',
              Copy(Data, 7, 2), '/',
              Copy(Data, 1, 2));
      END;                    {CASE}
      IF Len <= Length(Name) THEN
        Write(Copy(blanks, 1, Length(Name)-Pred(Len)))
      ELSE
        Write(' ');
      END;                    {WITH F}
    END;                      {ShowField}

  BEGIN                       {List}
  WriteLn;
  Write('Rec Num  ');
  WITH D DO
    BEGIN
    FOR i := 1 TO NumFields DO
      WITH Fields^[i] DO
        IF Len >= Length(Name) THEN
          Write(Name, Copy(blanks, 1, Succ(Len-Length(Name))))
        ELSE
          Write(Name, ' ');
    WriteLn;
    r := 1;
    WHILE r <= NumRecs DO
      BEGIN
      GetDbfRecord(Demo, r);
      IF NOT dbfOK THEN ErrorHalt(dbfError);
      WriteLn;
      Write(r:7:0, ' ');
      Write(Chr(CurRecord^[0])); { the 'deleted' indicator }
      FOR i := 1 TO NumFields DO
        ShowField(CurRecord^[Fields^[i].Off], Fields^[i]);
      r := r+1;
      END;                    {WHILE r }
    END;                      {WITH D }
  END;                        {List}

  PROCEDURE DisplayStructure(VAR D : dbfRecord);

  VAR
    i : Integer;

  BEGIN
  WITH D DO
    BEGIN
    ClrScr;
    Write(' #  Field Name   Type  Length  Decimal');
    FOR i := 1 TO NumFields DO
      BEGIN
      WITH Fields^[i] DO
        BEGIN
        IF i MOD 20 = 0 THEN
          BEGIN
          WriteLn;
          Wait;
          ClrScr;
          Write(' #  Field Name   Type  Length  Decimal');
          END;
        GoToXY(1, Succ(WhereY));
        Write(i:2, Name:12, Typ:5, Len:9);
        IF Typ = 'N' THEN Write(Dec:5);
        END;                  {WITH Fields^}
      END;                    {FOR}
    WriteLn;
    Wait;
    END;                      {WITH D}
  END;                        { DisplayStructure }

  PROCEDURE CopyDbf(fnDB2,fnDB3 : _Str64);
    {
    Copies a .DBF file to another file.  The SOURCE file may be a
    II, III, or III Plus file.  The DESTINATION file will be a III Plus
    file (although III will be able to use it with no problems).
    }

  VAR
    dOrg,dDest : dbfRecord;
    recCount : Real;
    x,y : Integer;
    dummyPtr : _dRec;

  BEGIN             { CopyDbf }
  dOrg.FileName := fnDB2;
  OpenDbf(dOrg);
  IF NOT dbfOK THEN ErrorHalt(dbfError);
  CreateDbf(dDest,fnDB3,dOrg.NumFields,dOrg.Fields);
  IF NOT dbfOK THEN ErrorHalt(dbfError);
  dummyPtr := dDest.CurRecord;
  dDest.CurRecord := dOrg.CurRecord;     { a dirty trick! }
  recCount := 0;
  WriteLn;
  x := WhereX; y := WhereY;
  Write(recCount:8:0,' Records Converted.');
  WHILE recCount < dOrg.NumRecs DO
    BEGIN
    recCount := recCount + 1;
    GetDbfRecord(dOrg,recCount);
    IF NOT dbfOK THEN ErrorHalt(dbfError);
    AppendDbf(dDest);     { go right into the append because both CurRecords }
                          {  point to the same place }
    IF NOT dbfOK THEN ErrorHalt(dbfError);
    GotoXY(x,y);
    Write(recCount:8:0);
    END;
  WriteLn;
  CloseDbf(dOrg);
  IF NOT dbfOK THEN ErrorHalt(dbfError);
  dDest.CurRecord := dummyPtr;      { It is important to undo the dirty work! }
  CloseDbf(dDest);
  IF NOT dbfOK THEN ErrorHalt(dbfError);
  END;              { CopyDbf }

VAR
  fn1,fn2,p : _Str64;

BEGIN                         {Demonstration of DBF routines}
WITH Demo DO
  BEGIN
  FillChar(blanks, SizeOf(blanks), $20);
  blanks[0] := Chr(255);
  ClrScr;
  GoToXY(10, 10);
  Write('Name of dBASE file (.DBF assumed): ');
  Read(FileName);
  IF Pos('.', FileName) = 0 THEN FileName := FileName+'.DBF';
  OpenDbf(Demo);
  IF NOT dbfOK THEN ErrorHalt(dbfError);
  ClrScr;
  SizeOfFile := LongFileSize(dFile);
  WriteLn('File Name: ', FileName);
  WriteLn('Date Of Last Update: ', DateOfUpdate);
  WriteLn('Number of Records: ', NumRecs:10:0);
  WriteLn('Size of File: ', SizeOfFile:15:0);
  WriteLn('Length of Header: ', HeadLen:11);
  WriteLn('Length of One Record: ', RecLen:7);
  IF WithMemo THEN WriteLn('This file contains Memo fields.');
  IF HeadProlog[0] = DB2File THEN WriteLn('dBASE 2.4 file');
  Wait;
  ClrScr;
  DisplayStructure(Demo);
  ClrScr;
  List(Demo);
  WriteLn;
  Wait;
  CloseDbf(Demo);
  IF NOT dbfOK THEN ErrorHalt(dbfError);
  END;                        {WITH}
ClrScr;
WriteLn('Enter the name of a dBASE file (II, III, or III +) to copy.');
Write('Enter a blank name to exit: ');
ReadLn(fn1);
IF fn1 = '' THEN Halt;
IF Pos('.', fn1) = 0 THEN fn1 := fn1+'.DBF';
Write('Enter destination file name: ');
ReadLn(fn2);
IF Pos('.', fn2) = 0 THEN fn2 := fn2+'.DBF';
CopyDbf(fn1,fn2);
END.                          {of Demo program }
*)